home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / fortran / fv121s.zip / DEMO.FOR < prev    next >
Text File  |  1988-05-28  |  18KB  |  553 lines
  1. c========================================================
  2. c
  3. c       demo.for        FAT-Video 1.20 Updated 1/28/88
  4. c
  5. c       Window demo for FAT-Video 1.20.
  6. c
  7. c          This program works with CGA,EGA and MONO
  8. c       monitors in modes 3 or 7.
  9. c
  10. c       marc a. norton
  11. c=========================================================
  12.       INTEGER*2 attr,ulr,ulc,nr,nc,rattr,xattr,i,j,k,l,icol
  13.       INTEGER*2 fore,back,inten,blink,mode,ncols,page,battr
  14.       INTEGER*2 scan,key,wid1,wid2,wid3,wids,wdx(16),wid0
  15.       integer*2 White,Yellow
  16.       integer*2 Black,Blue,Red
  17.       character title*80,string*80,infil*35,outfil*35
  18.       logical   POP
  19.       character    adap*3
  20.       INTEGER*2    isel,iopt,ii,ipos,im,ikey
  21.       character*20 prnam(10)
  22.       character*50 itnam(20),itmen(20)
  23. c----------------------------------------------------------------------
  24. c   prnam must be declared as char*20 for compatability with menbar().
  25. c   itnam must be declared as char*50 for compatability with wmenu().
  26. c----------------------------------------------------------------------
  27.  
  28. c------- get adapter
  29.       call cls()
  30.       call getmod(mode,ncols,page)
  31.       call getadp(adap)
  32.       IF(mode .eq. 3)THEN
  33.         White = 7
  34.         Yellow= 6
  35.         Black = 0
  36.         Blue  = 1
  37.         Red   = 4
  38.       END IF
  39.       IF(mode .eq. 7)THEN
  40.         White = 7
  41.         Yellow= 7
  42.         Black = 0
  43.         Blue  = 0
  44.         Red   = 0
  45.       END IF
  46.  
  47. c--------set border, if were on a true CGA adapter, not EGA in mode 3
  48. c        border on EGA is set with the overscan register.
  49.       if(adap.eq.'CGA')call setbc(7)
  50.  
  51. c------opening display-----------------
  52.       call opndis(infil,outfil)
  53.       call cls()
  54.  
  55.       inten=0
  56.       blink=0
  57.       call setab(attr,White,Blue,inten,blink)
  58. c---------make borderless backdrop window
  59.       call wopen(wids,attr,attr,0,0,23,78,char(0),0,0,0)
  60.   105 continue
  61.  
  62. c----------loc of window of ulr,ulc for window #1
  63.       ulr=3
  64.       ulc=10
  65.       nr = 15
  66.       nc = 60
  67. c--------------set window colors
  68.       inten= 0
  69.       blink= 0
  70. c----------setup the attr byte
  71.       call setab(attr,Yellow,Black,inten,blink)
  72.       call revab(attr,battr)
  73. c-----------open window #1
  74.       title='1: FAT-Video Demo`'
  75.       call setnul(title)
  76.       call wopen(wid1,battr,attr,ulr,ulc,nr,nc,title,1,0,0)
  77.  
  78. c-----------write a line of txt
  79.       title='    This is a demonstration of the simple`'
  80.       call wprint(wid1,title)
  81.       title=' windowing that can be performed with the`'
  82.       call wprint(wid1,title)
  83.       title=' FAT-Video utilities, in Fortran.`'
  84.       call wprint(wid1,title)
  85.       call wprint(wid1,' Notice, if you have a CGA monitor`')
  86.       call wprint(wid1,' the border color is now set, and`')
  87.       call wprint(wid1,' we have a background screen to work on. `')
  88.       call wcrlf(wid1)
  89.       call wprint(wid1,' Press a key to continue...`')
  90.       call rdkbd(scan,key)
  91.  
  92.       call wcls(wid1)
  93.       call wprint(wid1,' First we will examine some text i/o.`')
  94.       call wcrlf(wid1)
  95.       call wprint(wid1,' Press a key, and notice the key is echoed`')
  96.       call wprint(wid1,' to the screen.`')
  97.       call revab(attr,rattr)
  98.       call wgetce(wid1,rattr,key)
  99.       call wcrlf(wid1)
  100.       call wprint(wid1,' Enter a string and press return: `')
  101.       call setab(rattr,White,Blue,0,0)
  102.  
  103.       call wgetse(wid1,rattr,string,15)
  104.       call wcrlf(wid1)
  105.       call wprint(wid1,' Enter a string, and press return,`')
  106.       call wprint(wid1,' notice there is no echo.`')
  107.       call wgetsn(wid1,string,15)
  108.       call wcrlf(wid1)
  109.       call wprint(wid1,' Your string was: `' )
  110.       call wprint(wid1,string)
  111.       call wcrlf(wid1)
  112.       call wprint(wid1,' Press a key to continue.`')
  113.       call rdkbd(scan,key)
  114.  
  115.       call wcls(wid1)
  116.       call wprint(wid1,'  These have been some examples of the`')
  117.       call wprint(wid1,' kind of text input and output available`')
  118.       call wprint(wid1,' with or without the`')
  119.       call wprint(wid1,' windows, using the FAT-Video libraries.`')
  120.       call wprint(wid1,'  Examine the demo source code to see how`')
  121.       call wprint(wid1,' easy it is to use the window, and video`')
  122.       call wprint(wid1,' library functions. They are all simple`')
  123.       call wprint(wid1,' subroutine calls, but they provide some`')
  124.       call wprint(wid1,' very powerful tools for writing pleasant`')
  125.       call wprint(wid1,' user interfaces.`')
  126.       call wcrlf(wid1)
  127.       call wprint(wid1,' Press any key to continue...`')
  128.       call RDKBD(SCAN,KEY)
  129.       call wcls(wid1)
  130.  
  131. c--------------go to menuing now...
  132.       call wprint(wid1,' We will go on to menus now. There are 3`')
  133.       call wprint(wid1,' types of menus in FAT-Video. The first is`')
  134.       call wprint(wid1,' the menu-bar, it is the master menu and it`')
  135.       call wprint(wid1,' appears in row 1 of the window it is`')
  136.       call wprint(wid1,' placed in. The second is the Pull-Down menu,`')
  137.       call wprint(wid1,' it drops from`')
  138.       call wprint(wid1,' under the main menu-item selected.  The`')
  139.       call wprint(wid1,' third`')
  140.       call wprint(wid1,' is the Pop-Up menu, it just pops up on`')
  141.       call wpriNT(WID1,' screen`')
  142.       call wprint(wid1,' wherever you want.`')
  143.       call wprint(wid1,' Before we look at the menus, here`')
  144.       call wprint(wid1,' are some simple rules to follow:`')
  145.       call wcrlf(wid1)
  146.       call wcrlf(wid1)
  147.       call wprint(wid1,'   To move around, use the arrow keys.`')
  148.       call wcrlf(wid1)
  149.       call wprint(wid1,'   To select a menu-item, press return.`')
  150.       call wcrlf(wid1)
  151.       call wprint(wid1,'   To exit, without selecting, press Esc.`')
  152.       call wcrlf(wid1)
  153.       call wprint(wid1,'   To exit  the menus, select Exit.`')
  154.       call wcrlf(wid1)
  155.       call wcrlf(wid1)
  156.       call wprint(wid1,' Thats it, press a key to go on...`')
  157.       call RDKBD(SCAN,KEY)
  158.       call wcls(wid1)
  159.  
  160. c-----------DEFINE MAIN MENU ITEMS
  161.       prnam(1)='Menus`'
  162.       prnam(2)='Disk`'
  163.       prnam(3)='Math`'
  164.       prnam(4)='Special`'
  165.       prnam(5)='Junk`'
  166.       prnam(6)='Memory`'
  167.       prnam(7)='Exit`'
  168.       prnam(8)=char(0)
  169.  
  170. c---------define Menus-items
  171.       itmen(1) = ' Pop-Up    Menus `'
  172.       itmen(2) = ' Pull-Down Menus `'
  173.       itmen(3) = '`'
  174.  
  175. c----------- define dummy menu items here
  176.       itnam(1)  = 'item number 1  `'
  177.       itnam(2)  = 'item number 2  `'
  178.       itnam(3)  = 'item number 3  `'
  179.       itnam(4)  = 'item number 4  `'
  180.       itnam(5)  = 'item number 5  `'
  181.       itnam(6)  = 'item number 6  `'
  182.       itnam(7)  = 'item number 7  `'
  183.       itnam(8)  = 'item number 8  `'
  184.       itnam(9)  = 'item number 9  `'
  185.       itnam(10) = 'item number 10 `'
  186.       itnam(11) = 'item number 11 `'
  187.       itnam(12) = 'item number 12 `'
  188.       itnam(13)=char(0)
  189.  
  190. c-----------place some text, but not in row #1 !!!
  191.       call wsetcp(wid1,2,1)
  192.       call wprint(wid1,'   As you play with the menuing features`')
  193.       call wprint(wid1,' take notice that the sliding-bar menu in`')
  194.       call wprint(wid1,' row 1 may have diffent colors than the`')
  195.       call wprint(wid1,' Pop-Up and Pull-Down menus. The 1st item`')
  196.       call wprint(wid1,' in the Main menu is Menus, it is the only`')
  197.       call wprint(wid1,' functional menu in the demo. It can `')
  198.       call wprint(wid1,' dynamically switch between Pop-Up and`')
  199.       call wprint(wid1,' Pull-Down menus. Try the menus out, and`')
  200.       call wprint(wid1,' examine the source code, they are easy to`')
  201.       call wprint(wid1,' make and use.`')
  202.       POP = .FALSE.
  203. c---------start position of selected menu
  204.       call curoff()
  205.       ipos = 1
  206.   130 call revab(attr,rattr)
  207.       call menbar(wid1,prnam,attr,rattr,isel,ipos)
  208.       if(isel.eq.7)go to135
  209.       if(isel .eq. 0)go to 130
  210.  
  211. c--------select colors
  212.       call setab(xattr,White,Blue,0,0)
  213. C      call revab(xattr,rattr)
  214.       icol=30
  215.  
  216. c----------call Pop-Up or Pull-Down Menus
  217.       if(POP)then
  218.        if(isel.eq.1)then
  219.          call wmenu(itmen,attr,rattr,7,icol,prnam(isel),isel)
  220.         if(isel.eq.1)POP=.TRUE.
  221.         if(isel.eq.2)POP=.FA